home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / Browser.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1995-11-16  |  25.9 KB  |  759 lines  |  [TEXT/.Ob4]
  1. Syntax10.Scn.Fnt
  2. MODULE Browser;        (* J.Templ 16.8.89/16.12.92 *)    (* << RC 21.12.92, mah 12.1.94 *)
  3.     mah    16.11.95    error removed with 'xxx = SYS.PTR' (1)
  4.     IMPORT SYSTEM, Files, Texts, MenuViewers, TextFrames, Oberon;
  5.     CONST
  6.         OptionChar = "/";
  7.         IdBufLeng = 12000;
  8.         IdBufLim = IdBufLeng - 100;
  9.         maxImps = 30;
  10.         SFtag = 0F7X;
  11.         firstStr = 16;
  12.     (*object modes*)
  13.         Var =  1; Ind =  2; Con =  3; Fld = 4; Typ = 5; XProc = 6;
  14.         CProc = 7; IProc = 8; Mod = 9; Head = 10; TProc = 11;
  15.     (*Structure forms*)
  16.         Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  17.         Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  18.         Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  19.     TYPE
  20.         Object = POINTER TO ObjDesc;
  21.         Struct = POINTER TO StrDesc;
  22.         ObjDesc = RECORD
  23.             left, right, link: Object;
  24.             typ:  Struct;
  25.             name: INTEGER;
  26.             mode: SHORTINT;
  27.             marked: BOOLEAN;
  28.             a0, a1:  LONGINT;    (* a0 gives org in module list *)
  29.             next: Object;         (* next module *)
  30.         END ;
  31.         StrDesc = RECORD
  32.             form, mno, ref, level: SHORTINT;
  33.             n, size, adr: LONGINT;    (* adr gives org in type hierarchy *)
  34.             BaseTyp: Struct;
  35.             link, strobj: Object;
  36.             sub, next: Struct    (* type hierarchy *)
  37.         END ;
  38.         W: Texts.Writer;
  39.         id: INTEGER;
  40.         err: BOOLEAN;
  41.         universe, topScope: Object;
  42.         undftyp, bytetyp, booltyp, chartyp, sinttyp, inttyp, linttyp,
  43.         realtyp, lrltyp, settyp, stringtyp, niltyp, notyp, sysptrtyp: Struct;
  44.         nofGmod: INTEGER;   (*nof imports*)
  45.         option: CHAR;
  46.         first, showObj: BOOLEAN;
  47.         GlbMod: ARRAY maxImps OF Object;
  48.         IdBuf: ARRAY IdBufLeng OF CHAR;
  49.         types: Struct;
  50.         symFileExt: ARRAY 8 OF CHAR;
  51.         (*needed for detecting import of SYSTEM *)
  52.         syspos: LONGINT;
  53.         impSystem: BOOLEAN;    (* insert "SYSTEM, " at imppos or "    IMPORT SYSTEM; cr cr" at -imppos *)
  54.     PROCEDURE Ws(s: ARRAY OF CHAR); BEGIN Texts.WriteString(W, s) END Ws;
  55.     PROCEDURE Wch(ch: CHAR); BEGIN Texts.Write(W, ch) END Wch;
  56.     PROCEDURE Wln; BEGIN Texts.WriteLn(W) END Wln;
  57.     PROCEDURE WriteName(obj: Object);    
  58.         VAR name: ARRAY 32 OF CHAR; i, n: INTEGER;
  59.     BEGIN n := obj^.name;
  60.         i := -1; REPEAT INC(i); name[i] := IdBuf[n + i] UNTIL name[i] = 0X;
  61.         Ws(name)
  62.     END WriteName;
  63.     PROCEDURE WAdr(obj: Object);                                                                        (* << *)
  64.         VAR adr: LONGINT;
  65.     BEGIN
  66.         IF option = "X" THEN
  67.             adr := obj^.a0;
  68.             IF adr < 0 THEN adr := -1-adr;
  69.                 IF adr DIV 32 = 16 THEN Texts.Write(W, "R") ELSE Texts.Write(W, "F") END;
  70.                 Texts.WriteInt(W, adr MOD 32, 0)
  71.             ELSE
  72.                 Texts.WriteInt(W, adr, 0)
  73.             END;
  74.             Wch(" ")
  75.         END
  76.     END WAdr;
  77.     PROCEDURE Indent(i: INTEGER);    
  78.     BEGIN WHILE i > 0 DO Wch(9X); DEC(i) END
  79.     END Indent;
  80.     PROCEDURE WriteRecords(typ: Struct; i: INTEGER);
  81.     BEGIN
  82.         WHILE typ # NIL DO
  83.             Indent(i);
  84.             WriteName(GlbMod[typ.mno]); Wch("."); WriteName(typ.strobj); 
  85.             Wln; WriteRecords(typ^.sub, i + 1);
  86.             typ := typ^.next
  87.         END
  88.     END WriteRecords;
  89.     PROCEDURE WriteModules(m: Object);    
  90.     BEGIN
  91.         WHILE m # NIL DO
  92.             m^.a0 := W.buf.len;
  93.             WriteName(m); Wln;
  94.             m := m^.next
  95.         END
  96.     END WriteModules;
  97.     PROCEDURE^ WriteType(typ: Struct; i: INTEGER);
  98.     PROCEDURE WriteBase(typ: Struct);    
  99.         VAR base: Struct;
  100.     BEGIN base := typ^.BaseTyp;
  101.         IF (base # NIL) & (base^.strobj^.marked OR (option = "X")) THEN
  102.             Ws(" ("); WriteType(typ^.BaseTyp, 0);
  103.             IF option = "x" THEN WriteBase(typ^.BaseTyp) END ;
  104.             Wch(")")
  105.         END;
  106.     END WriteBase;
  107.     PROCEDURE WriteFields(VAR obj: Object; i: INTEGER);
  108.         VAR typ: Struct; mode: INTEGER;
  109.     BEGIN typ := obj^.typ; mode := obj^.mode;
  110.         LOOP
  111.             WAdr(obj); WriteName(obj);
  112.             IF obj^.marked THEN Wch("-") END ;
  113.             obj := obj^.link;
  114.             IF (obj = NIL) OR (obj^.mode # mode) OR (obj^.typ # typ) THEN EXIT END ;
  115.             Ws(", ")
  116.         END ;
  117.         Ws(": "); WriteType(typ, i + 1)
  118.     END WriteFields;
  119.     PROCEDURE WriteParams(param: Object; res: Struct);
  120.     BEGIN
  121.         IF (param # NIL) OR (res # notyp) THEN
  122.             Ws(" (");
  123.             WHILE (param # NIL) DO
  124.                 IF param.mode = Ind THEN Ws("VAR ") END ;
  125.                 IF param.name = 0 THEN
  126.                     WriteType(param.typ, 0);
  127.                     param := param.link;
  128.                     IF param # NIL THEN Ws(", ") END
  129.                 ELSE
  130.                     WriteFields(param, 0);
  131.                     IF param # NIL THEN Ws("; ") END
  132.                 END
  133.             END ;
  134.             Wch(")");
  135.         END ;
  136.         IF res # notyp THEN Ws(": "); WriteType(res, 0) END
  137.     END WriteParams;
  138.     PROCEDURE WriteFieldList(obj: Object; i: INTEGER);    
  139.     BEGIN
  140.         WHILE (obj # NIL) & (obj^.mode = Fld) DO
  141.             Indent(i); WriteFields(obj, i); Wch(";"); Wln
  142.         END ;
  143.         WHILE (obj # NIL) & (obj^.mode = TProc) DO
  144.             Indent(i);
  145.             IF option = "X" THEN Texts.WriteInt(W, obj^.a0 MOD 10000H,1); Wch(" ");
  146.                 Texts.WriteInt(W, obj^.a0 DIV 10000H,1); Wch(" ")
  147.             END ;
  148.             Ws("PROCEDURE (");
  149.             IF obj^.right^.mode = Ind THEN Ws("VAR ") END ;
  150.             WAdr(obj^.right);
  151.             WriteName(obj^.right);
  152.             Ws(": ");
  153.             WriteName(obj^.right^.typ^.strobj);
  154.             Ws(") ");
  155.             WriteName(obj);
  156.             WriteParams(obj^.right^.link, obj^.typ);
  157.             Wch(";"); Wln;
  158.             obj := obj^.link
  159.         END
  160.     END WriteFieldList;
  161.     PROCEDURE WriteInstVars(typ: Struct; i: INTEGER);    
  162.     BEGIN
  163.         IF typ # NIL THEN
  164.             IF option = "x" THEN WriteInstVars(typ^.BaseTyp, i) END;
  165.             WriteFieldList(typ^.link, i);
  166.         END
  167.     END WriteInstVars;
  168.     PROCEDURE WriteForm(typ: Struct; i: INTEGER);    
  169.         VAR param, p: Object;
  170.     BEGIN
  171.         IF typ^.form = Record THEN
  172.             Ws("RECORD"); WriteBase(typ);
  173.             IF option = "X" THEN Wch(" "); Texts.WriteInt(W, typ^.size, 1); Wch(" ") END ;
  174.             IF (typ^.link # NIL) OR (option = "x") THEN Wln; WriteInstVars(typ, i); Indent(i - 1) ELSE Wch(" ") END ;
  175.             Ws("END ")
  176.         ELSIF typ^.form = Array THEN
  177.             Ws("ARRAY "); Texts.WriteInt(W, typ^.n, 0); Ws(" OF "); WriteType(typ^.BaseTyp, i)
  178.         ELSIF typ^.form = DynArr THEN
  179.             Ws("ARRAY OF "); WriteType(typ^.BaseTyp, i)
  180.         ELSIF typ^.form = Pointer THEN
  181.             Ws("POINTER TO "); WriteType(typ^.BaseTyp, i)
  182.         ELSIF typ^.form = ProcTyp THEN
  183.             Ws("PROCEDURE");
  184.             WriteParams(typ^.link, typ^.BaseTyp)
  185.         END
  186.     END WriteForm;
  187.     PROCEDURE WriteType(typ: Struct; i: INTEGER);    
  188.     BEGIN
  189.         IF typ^.strobj # NIL THEN
  190.             IF (typ = bytetyp) OR (typ = sysptrtyp) THEN impSystem := TRUE END ;
  191.             IF (typ^.mno > 1) OR ((typ^.mno = 1) & showObj) THEN WriteName(GlbMod[typ^.mno]); Wch(".") END ;
  192.             WriteName(typ^.strobj)
  193.         ELSE WriteForm(typ, i)
  194.         END
  195.     END WriteType;
  196.     PROCEDURE WriteProc(obj: Object);
  197.         VAR param: Object; i: LONGINT;
  198.     BEGIN
  199.         IF (option = "X") & (obj^.mode # CProc) THEN Texts.WriteInt(W, obj^.a0, 2); Indent(1) END ;
  200.         Ws("PROCEDURE ");
  201.         IF obj^.mode = CProc THEN Wch("-") ELSIF obj^.mode = IProc THEN Wch("+") END;
  202.         WriteName(obj);
  203.         WriteParams(obj^.link, obj^.typ);
  204.         IF obj^.mode = CProc THEN Wch(" "); i := 0; 
  205.             WHILE i < obj^.a1 DO
  206.                 Texts.WriteInt(W, ORD(IdBuf[obj^.a0 + i]), 1); INC(i);
  207.                 IF i < obj^.a1 THEN Ws(", ") END
  208.             END ;
  209.         END ;
  210.         Wch(";")
  211.     END WriteProc;
  212.     PROCEDURE WriteVal(obj: Object);
  213.         VAR i: INTEGER; lr: LONGREAL; s: SET; ch: CHAR;
  214.     BEGIN
  215.         CASE obj.typ^.form OF
  216.             SInt, Int, LInt:    Texts.WriteInt(W, obj^.a0, 0) |
  217.             Real:    Texts.WriteReal(W, SYSTEM.VAL(REAL, obj^.a0), 16) |
  218.             LReal:    SYSTEM.MOVE(SYSTEM.ADR(obj^.a0), SYSTEM.ADR(lr), 8); Texts.WriteLongReal(W, lr, 23) |
  219.             Bool:    IF obj^.a0 = 0 THEN Ws("FALSE") ELSE Ws("TRUE") END |
  220.             Char:    IF (obj^.a0 >= 32) & (obj^.a0 <= 126) THEN 
  221.                             Wch(22X); Wch(CHR(obj^.a0)); Wch(22X)
  222.                         ELSE
  223.                             i := SHORT(obj^.a0 DIV 16);
  224.                             IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END;
  225.                             i := SHORT(obj^.a0 MOD 16);
  226.                             IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END;
  227.                             Wch("X")
  228.                         END |
  229.             Set:    Wch("{"); i := 0; s := SYSTEM.VAL(SET, obj^.a0);
  230.                         WHILE i <= MAX(SET) DO
  231.                             IF MAX(SET)-i IN s THEN Texts.WriteInt(W, i, 0); EXCL(s, MAX(SET)-i);
  232.                                 IF s # {} THEN Ws(", ") END
  233.                             END ;
  234.                             INC(i)
  235.                         END ;
  236.                         Wch("}") |
  237.             NilTyp:    Ws("NIL") |
  238.             String: i := SHORT(obj^.a0); ch := IdBuf[i]; Wch(22X);
  239.                         WHILE ch # 0X DO Wch(ch); INC(i); ch := IdBuf[i] END ;
  240.                         Wch(22X)
  241.         END
  242.     END WriteVal;
  243.     PROCEDURE WriteObject(VAR obj: Object; mode: INTEGER);
  244.     BEGIN
  245.         IF mode = Con THEN
  246.             IF first THEN Indent(1); Ws("CONST"); Wln; first := FALSE END;
  247.             Indent(2); WriteName(obj); Ws(" = "); WriteVal(obj); Wch(";");
  248.             Wln
  249.         ELSIF mode = Var THEN
  250.             IF first THEN Indent(1); Ws("VAR"); Wln; first := FALSE END;
  251.             Indent(2);
  252.             LOOP
  253.                 WAdr(obj); WriteName(obj);
  254.                 IF obj^.marked THEN Wch("-") END ;
  255.                 IF (obj^.right = NIL) OR (obj^.right^.mode # obj^.mode) OR (obj^.right^.typ # obj^.typ) THEN EXIT END ;
  256.                 Ws(", "); obj := obj^.right
  257.             END ;
  258.             Ws(": "); WriteType(obj^.typ, 3); Wch(";");
  259.             Wln
  260.         ELSIF (mode = Typ) & (obj^.marked) THEN
  261.             IF first THEN Indent(1); Ws("TYPE"); Wln; first := FALSE END;
  262.             Indent(2); WriteName(obj); Ws(" = ");
  263.             IF obj^.typ^.strobj # obj THEN WriteType(obj^.typ, 0)    (* alias type *)
  264.             ELSE WriteForm(obj^.typ, 3)
  265.             END ;
  266.             Wch(";"); Wln;
  267.             IF showObj THEN
  268.                 IF (obj^.typ^.form = Pointer) & (obj^.typ^.BaseTyp^.strobj # NIL) THEN
  269.                     WriteObject(obj^.typ^.BaseTyp^.strobj, obj^.typ^.BaseTyp^.strobj.mode)
  270.                 END
  271.             ELSIF (obj^.typ^.form # Pointer) OR (obj^.typ^.BaseTyp = NIL) OR (obj^.typ^.BaseTyp^.strobj = NIL) THEN Wln  (* mah (1) *)
  272.             END
  273.         ELSIF mode IN {XProc, IProc, CProc} THEN first := FALSE; Indent(1); WriteProc(obj); Wln
  274.         ELSIF mode = Mod THEN
  275.             IF first THEN Indent(1); Ws("IMPORT "); first := FALSE; syspos := W.buf.len ELSE Ws(", ") END;
  276.             WriteName(obj);
  277.             IF option = "X" THEN Texts.WriteHex(W, obj^.a1) END
  278.         END
  279.     END WriteObject;
  280.     PROCEDURE WriteScope(obj: Object; mode: INTEGER);
  281.     BEGIN
  282.         first := TRUE;
  283.         WHILE obj # NIL DO
  284.             IF (obj.mode = mode) OR ((mode = XProc) & (obj.mode IN {CProc, IProc})) THEN WriteObject(obj, mode) END ;
  285.             obj := obj^.right
  286.         END ;
  287.         IF ~first THEN
  288.             IF mode = Mod THEN Wch(";"); Wln END ;
  289.             Wln
  290.         END
  291.     END WriteScope;
  292.     PROCEDURE ReorderTypes(mod: Object);    (* make <pointer, record> pairs *)
  293.         VAR p, q, head, h: Object; typ: Struct;
  294.     BEGIN q := mod^.link;
  295.         NEW(head); head^.right := q;
  296.         WHILE q # NIL DO
  297.             IF (q.mode = Typ) & (q^.typ^.form = Pointer) & (q^.typ^.BaseTyp # NIL) & (q^.typ^.BaseTyp^.strobj # NIL) THEN (* mah (1) *)
  298.                 p := head; typ := q^.typ^.BaseTyp;
  299.                 WHILE (p^.right # NIL) & ((p^.right^.mode # Typ) OR (p^.right^.typ # typ)) DO p := p^.right END ;
  300.                 IF p^.right # NIL THEN
  301.                     h := p^.right; p^.right := h^.right; h^.right := q^.right; q^.right := h
  302.                 END
  303.             END ;
  304.             q := q^.right
  305.         END ;
  306.         mod^.link := head^.right
  307.     END ReorderTypes;
  308.     PROCEDURE WriteModule(mod: Object);
  309.     BEGIN
  310.         Ws("DEFINITION "); WriteName(mod);
  311.         IF option = "X" THEN Texts.WriteHex(W, mod^.a1) END ;
  312.         Wch(";"); Wln; Wln;
  313.         syspos := - W.buf.len; impSystem := FALSE;
  314.         WriteScope(mod^.link, Mod);
  315.         WriteScope(mod^.link, Con);
  316.         ReorderTypes(mod); WriteScope(mod^.link, Typ);
  317.         WriteScope(mod^.link, Var);
  318.         WriteScope(mod^.link, CProc);
  319.         WriteScope(mod^.link, XProc);
  320.         Ws("END "); WriteName(mod); Wch(".")
  321.     END WriteModule;
  322.     PROCEDURE Diff(i, j: INTEGER): INTEGER;
  323.         VAR d: INTEGER; ch: CHAR;
  324.     BEGIN
  325.         REPEAT ch := IdBuf[i]; d := ORD(ch) - ORD(IdBuf[j]); INC(i); INC(j)
  326.         UNTIL (d # 0) OR (ch = 0X);
  327.         RETURN d
  328.     END Diff;
  329.     PROCEDURE Index(name: ARRAY OF CHAR): INTEGER;    
  330.         VAR id0, j: INTEGER; ch: CHAR; (*enter identifier*)
  331.     BEGIN
  332.         id0 := id; j := 0;
  333.         IF id < IdBufLim THEN
  334.             REPEAT ch := name[j]; IdBuf[id] := ch; INC(id); INC(j)
  335.             UNTIL ch = 0X
  336.         ELSE err := TRUE
  337.         END ;
  338.         RETURN id0
  339.     END Index;
  340.     PROCEDURE Insert(name: INTEGER; VAR obj: Object);    
  341.         VAR d: INTEGER; ob0, ob1: Object;
  342.     BEGIN
  343.         ob0 := topScope; ob1 := ob0^.right; d := 1;
  344.         LOOP
  345.             IF ob1 # NIL THEN
  346.                 d := Diff(name, ob1^.name);
  347.                 IF d < 0 THEN ob0 := ob1; ob1 := ob0^.left
  348.                 ELSIF d > 0 THEN ob0 := ob1; ob1 := ob0^.right
  349.                 ELSE ob1 := NIL (* already defined, cause duplication *)
  350.                 END
  351.             ELSE (*insert*) NEW(ob1);
  352.                 IF d < 0 THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ;
  353.                 ob1^.left := NIL; ob1^.right := NIL; ob1^.name := name;
  354.                 ob1^.marked := FALSE; EXIT
  355.             END
  356.         END ;
  357.         obj := ob1
  358.     END Insert;
  359.     PROCEDURE InsertSubClass(base, sub: Struct);    
  360.         VAR prev: Struct;
  361.         PROCEDURE Less(typ1, typ2: Struct): BOOLEAN;    (* return typ1 < typ2 *)
  362.             VAR i: INTEGER;
  363.         BEGIN
  364.             i := Diff(GlbMod[typ1^.mno]^.name, GlbMod[typ2^.mno]^.name);
  365.             IF i < 0 THEN RETURN TRUE
  366.             ELSIF i = 0 THEN RETURN Diff(typ1^.strobj^.name, typ2^.strobj^.name) < 0
  367.             ELSE RETURN FALSE
  368.             END
  369.         END Less;
  370.     BEGIN
  371.         IF base = NIL THEN base := types END ;
  372.         prev := base^.sub;
  373.         IF (prev = NIL) OR Less(sub, prev) THEN
  374.             sub^.next := base^.sub; base^.sub := sub
  375.         ELSE
  376.             WHILE (prev^.next # NIL) & Less(prev^.next, sub) DO prev := prev^.next END;
  377.             sub^.next := prev^.next; prev^.next := sub
  378.         END
  379.     END InsertSubClass;
  380.     PROCEDURE InsertImport(obj, root: Object; VAR old: Object);    
  381.         VAR ob0, ob1: Object; d: INTEGER;
  382.     BEGIN ob0 := root; ob1 := ob0^.right; d := 1;
  383.         LOOP
  384.             IF ob1 # NIL THEN
  385.                 d := Diff(obj^.name, ob1^.name);
  386.                 IF d = 0 THEN old := ob1; EXIT
  387.                 ELSE ob0 := ob1; ob1 := ob1^.right
  388.                 END
  389.             ELSE ob1 := obj; ob0^.right := ob1;
  390.                 ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT
  391.             END
  392.         END
  393.     END InsertImport;
  394.     PROCEDURE Append(VAR d: ARRAY OF CHAR; s: ARRAY OF CHAR);
  395.         VAR i, j: INTEGER; ch: CHAR;
  396.     BEGIN
  397.         i := 0; WHILE d[i] # 0X DO INC(i) END ;
  398.         j := 0; REPEAT ch := s[j]; d[i] := ch; INC(i); INC(j) UNTIL ch = 0X
  399.     END Append;
  400.     PROCEDURE ReadSym(name: ARRAY OF CHAR; VAR obj: Object);    
  401.         VAR i, j, m, h1, h2, s, class: INTEGER; k: LONGINT;
  402.                 nofLmod, strno, parlev, fldlev: INTEGER;
  403.                 old, mod: Object;
  404.                 typ: Struct;
  405.                 ch: CHAR;
  406.                 si: SHORTINT;
  407.                 xval: REAL; yval: LONGREAL;
  408.                 LocMod:  ARRAY maxImps OF Object;
  409.                 struct:  ARRAY 255 OF Struct;    (* << RC *)
  410.                 param, lastpar, fldlist, lastfld: ARRAY 6 OF Object;
  411.                 FileName: ARRAY 32 OF CHAR;
  412.                 SymFile: Files.File;
  413.                 SF: Files.Rider;
  414. (* << RC *)
  415.         PROCEDURE ReadInt(VAR i: INTEGER); VAR k: LONGINT; BEGIN Files.ReadNum(SF, k); i := SHORT(k) END ReadInt;
  416.         PROCEDURE ReadXInt(VAR k: LONGINT); BEGIN Files.ReadNum(SF, k) END ReadXInt;
  417.         PROCEDURE ReadLInt(VAR k: LONGINT); BEGIN Files.ReadNum(SF, k) END ReadLInt;
  418.         PROCEDURE ReadId;    
  419.             VAR i: INTEGER; ch: CHAR;
  420.         BEGIN i := id;
  421.             REPEAT
  422.                 Files.Read(SF, ch); IdBuf[i] := ch; INC(i)
  423.             UNTIL ch = 0X;
  424.             id := i
  425.         END ReadId;
  426.         PROCEDURE Err(s: ARRAY OF CHAR);    
  427.         BEGIN
  428.             Ws(name); Ws(" -- "); Ws(s);
  429.             Wln; Texts.Append(Oberon.Log, W.buf)
  430.         END Err;
  431.         PROCEDURE reverseList(p: Object);    
  432.             VAR q, r: Object;
  433.         BEGIN q := NIL;
  434.             WHILE p # NIL DO
  435.                 r := p^.link; p^.link := q; q := p; p := r
  436.             END
  437.         END reverseList;
  438.         PROCEDURE AppendObj(VAR p: Object; obj: Object);
  439.             VAR r: Object;
  440.         BEGIN
  441.             IF p = NIL THEN p := obj
  442.             ELSE r := p; WHILE r^.link # NIL DO r := r^.link END ;
  443.                 r^.link := obj
  444.             END
  445.         END AppendObj;
  446.         PROCEDURE FlipBits (i: LONGINT): LONGINT;
  447.             VAR s, d: SET;
  448.         BEGIN
  449.             s := SYSTEM.VAL(SET, i); d := {}; i := 0;
  450.             WHILE i < 32 DO IF i IN s THEN INCL(d, 31-i) END; INC(i) END;
  451.             RETURN SYSTEM.VAL(LONGINT, d)
  452.         END FlipBits;
  453.     BEGIN    (* ReadSym *)
  454.         err := TRUE;
  455.         nofLmod := 0; strno := firstStr;
  456.         parlev := 0; fldlev := 0;
  457.         COPY(name, FileName); Append(FileName, symFileExt);
  458.         SymFile := Files.Old(FileName);
  459.         IF SymFile # NIL THEN
  460.             Files.Set(SF, SymFile, 0); Files.Read(SF, ch);
  461.             IF ch = SFtag THEN
  462.                 struct[Undef] := undftyp; struct[Byte] := bytetyp;
  463.                 struct[Bool] := booltyp;  struct[Char] := chartyp;
  464.                 struct[SInt] := sinttyp;  struct[Int] := inttyp;
  465.                 struct[LInt] := linttyp;  struct[Real] := realtyp;
  466.                 struct[LReal] := lrltyp;  struct[Set] := settyp;
  467.                 struct[String] := stringtyp; struct[NilTyp] := niltyp;
  468.                 struct[NoTyp] := notyp; struct[Pointer] := sysptrtyp;                                                                (*:*)
  469.                 LOOP (*read next item from symbol file*)
  470.                     Files.Read(SF, ch); class := ORD(ch);
  471.                     IF SF.eof THEN EXIT END ;
  472.                     CASE class OF
  473.                       0..7, 23, 25: (*object*)                                                                                                            (*:*)
  474.                         NEW(obj); m := 0;
  475.                         ReadInt(s); obj^.typ := struct[s];
  476.                         CASE class OF
  477.                             1: obj^.mode := Con;
  478.                                         CASE obj^.typ^.form OF
  479.                                         | 1,2,3: Files.Read(SF, ch); obj^.a0 := ORD(ch)
  480.                                         | 4: Files.Read(SF, si); obj^.a0 := si
  481.                                         | 5: ReadXInt(obj^.a0)
  482.                                         | 6: ReadLInt(obj^.a0)    (* << RC *)
  483.                                         | 9: ReadLInt(obj^.a0); obj^.a0 := FlipBits(obj^.a0)    (* << mmb *)
  484.                                         | 7: Files.ReadReal(SF, SYSTEM.VAL(REAL, obj^.a0))    (* << mmb *)
  485.                                         | 8: Files.ReadLReal(SF, yval);
  486.                                             SYSTEM.MOVE(SYSTEM.ADR(yval), SYSTEM.ADR(obj^.a0), 8);    (* << mmb *)
  487.                                         | 10: obj^.a0 := id; ReadId
  488.                                         | 11: (*NIL*)
  489.                                         END
  490.                             |2,3: obj^.mode := Typ; ReadInt(m);
  491.                                         IF obj^.typ^.strobj = NIL THEN obj^.typ^.strobj := obj END;
  492.                                         obj^.marked := class = 2
  493.                             |4, 23: obj^.mode := Var; ReadLInt(obj^.a0); obj^.marked := (class = 23)    (* << RC *)
  494.                             |5, 6, 7, 25:                                                                                                                      (*:*)
  495.                                         h1 := 0; h2 := 0;                                                                                            (*:*)
  496.                                         IF class = 5 THEN obj^.mode := IProc; ReadInt(h1)
  497.                                         ELSIF class = 6 THEN obj^.mode := XProc; ReadInt(h1)
  498.                                         ELSIF class = 25 THEN obj^.mode := TProc;
  499.                                             ReadInt(s); ReadInt(h1); ReadInt(h2);
  500.                                             typ := struct[s]
  501.                                         ELSE obj^.mode := CProc; Files.Read(SF, ch); i := ORD(ch);
  502.                                             obj^.a0 := id; obj^.a1 := i; 
  503.                                             WHILE i > 0 DO Files.Read(SF, IdBuf[id]); INC(id); DEC(i) END
  504.                                         END ;
  505.                                         IF class # 7 THEN obj^.a0 := h1 + h2 * 10000H END ;
  506.                                         reverseList(lastpar[parlev]);
  507.                                         obj^.link := param[parlev]^.right; DEC(parlev)
  508.                         END ;
  509.                         obj^.name := id; ReadId;
  510.                         IF (class = 6) & (fldlev > 0) THEN InsertImport(obj, fldlist[fldlev], old)
  511.                         ELSIF class = 25 THEN obj^.right := obj^.link; obj^.link:= NIL; AppendObj(typ^.link, obj)            (*:*)
  512.                         ELSE
  513.                             IF IdBuf[obj^.name] # 0X THEN
  514.                                 InsertImport(obj, LocMod[m], old);
  515.                                 IF (old # NIL) & (obj^.mode = Typ) THEN struct[s] := old^.typ
  516.                                 ELSIF (obj^.mode = Typ) & (obj^.typ^.form = Record) & (obj^.typ^.strobj = obj) THEN 
  517.                                     InsertSubClass(typ^.BaseTyp, typ)
  518.                                 END
  519.                             END
  520.                         END
  521.                     | 8..12: (*structure*)
  522.                         NEW(typ); typ^.strobj := NIL; typ^.ref := 0;
  523.                         ReadInt(s); typ^.BaseTyp := struct[s];
  524.                         ReadInt(s); typ^.mno := SHORT(SHORT(LocMod[s]^.a0));
  525.                         CASE class OF
  526.                              8: typ^.form := Pointer; typ^.size := 4; typ^.n := 0
  527.                         |  9: typ^.form := ProcTyp; typ^.size := 4; 
  528.                                     reverseList(lastpar[parlev]);
  529.                                     typ^.link := param[parlev]^.right; DEC(parlev)
  530.                         | 10: typ^.form := Array; ReadLInt(typ^.size); typ^.n := typ^.size DIV typ^.BaseTyp^.size
  531.                         | 11: typ^.form := DynArr; ReadLInt(typ^.size); ReadXInt(typ^.adr)
  532.                         | 12: typ^.form := Record;
  533.                                     ReadLInt(typ^.size);
  534.                                     reverseList(lastfld[fldlev]);
  535.                                     typ^.link := fldlist[fldlev]^.right; DEC(fldlev);
  536.                                     typ^.level := typ^.BaseTyp^.level;
  537.                                     IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END ;
  538.                                     ReadXInt(typ^.adr);  (*of descriptor*)
  539.                         END ;
  540.                         struct[strno] := typ; INC(strno)
  541.                     | 13: (*parameter list start*)
  542.                         NEW(obj); obj^.mode := Head; obj^.right := NIL;
  543.                         IF parlev < 6 THEN INC(parlev); param[parlev] := obj; lastpar[parlev] := NIL
  544.                         ELSE RETURN
  545.                         END
  546.                     | 14, 15: (*parameter*)
  547.                         NEW(obj);
  548.                         IF class = 14 THEN obj^.mode := Var ELSE obj^.mode := Ind END ;
  549.                         ReadInt(s); obj^.typ := struct[s];
  550.                         ReadXInt(obj^.a0); obj^.name := id; ReadId;
  551.                         InsertImport(obj, param[parlev], old);
  552.                         obj^.link := lastpar[parlev]; lastpar[parlev] := obj
  553.                     | 16: (*start field list*)
  554.                         NEW(obj); obj^.mode := Head; obj^.right := NIL;
  555.                         IF fldlev < 5 THEN INC(fldlev); fldlist[fldlev] := obj; lastfld[fldlev] := NIL
  556.                         ELSE RETURN
  557.                         END
  558.                     | 17, 24: (*field, rfield*)
  559.                         NEW(obj); obj^.mode := Fld; ReadInt(s);
  560.                         obj^.marked := (class = 24);
  561.                         obj^.typ := struct[s]; ReadLInt(obj^.a0);
  562.                         obj^.name := id; ReadId;
  563.                         obj^.link := lastfld[fldlev]; lastfld[fldlev] := obj;
  564.                         InsertImport(obj, fldlist[fldlev], old)
  565.                     | 18, 19: (*hidden pointer field, hidden procedure field *)
  566.                         ReadLInt(k)
  567.                     | 20: (*fixup pointer typ*)
  568.                         ReadInt(s); typ := struct[s];
  569.                         ReadInt(s);
  570.                         IF typ^.BaseTyp = undftyp THEN typ^.BaseTyp := struct[s] END
  571.                     | 21: (*skip sysflag*)
  572.                         ReadInt(s); ReadInt(s)
  573.                     | 22: (*module anchor*)
  574.                         ReadLInt(k); m := id; ReadId; i := 0;
  575.                         WHILE (i < nofGmod) & (Diff(m, GlbMod[i]^.name) # 0) DO
  576.                             INC(i)
  577.                         END ;
  578.                         IF i < nofGmod THEN (*module already present*)
  579.                             IF k # GlbMod[i]^.a1 THEN Err("invalid module key"); RETURN END ;
  580.                             obj := GlbMod[i]
  581.                         ELSE NEW(obj);
  582.                             obj^.mode := Head; obj^.name := m;
  583.                             obj^.a1 := k; obj^.a0 := nofGmod; obj^.right := NIL;
  584.                             IF nofGmod < maxImps THEN GlbMod[nofGmod] := obj; INC(nofGmod)
  585.                             ELSE RETURN
  586.                             END
  587.                         END ;
  588.                         IF nofLmod < 20 THEN LocMod[nofLmod] := obj; INC(nofLmod)
  589.                         ELSE Err("too many imports"); RETURN
  590.                         END ;
  591.                         IF nofLmod > 1 THEN NEW(mod); mod^.name := obj^.name; mod^.mode := Mod; mod^.a1 := k;
  592.                             InsertImport(mod, LocMod[0], old)
  593.                         END
  594.                     | 26: (*nofmethods*)
  595.                         ReadInt(s); ReadInt(h1); struct[s].n := h1
  596.                     | 27: (*hidden method*)
  597.                         ReadInt(s); ReadInt(s); ReadInt(s)
  598.                     ELSE Err("invalid symbol file"); RETURN
  599.                     END
  600.                 END (*LOOP*) ;
  601.                 Insert(Index(name), obj);
  602.                 obj^.mode := Mod; obj^.link := LocMod[0]^.right;
  603.                 obj^.a0  := LocMod[0]^.a0; obj^.a1  := LocMod[0]^.a1; obj^.typ := notyp;
  604.             ELSE Err("not a symbol file"); RETURN
  605.             END
  606.         ELSE Err("symbol file not found"); RETURN
  607.         END;
  608.         err := FALSE
  609.     END ReadSym;
  610.     PROCEDURE DisplayW(name: ARRAY OF CHAR);    
  611.         VAR mV: MenuViewers.Viewer; T: Texts.Text; x, y: INTEGER;
  612.     BEGIN
  613.         T := TextFrames.Text(""); Texts.Append(T, W.buf);
  614.         IF (syspos # 0) & impSystem THEN
  615.             IF syspos > 0 THEN Ws("SYSTEM, ") ELSE Wch(09X); Ws("IMPORT SYSTEM;"); Wln; Wln END;
  616.             Texts.Insert(T, ABS(syspos), W.buf);
  617.             syspos := 0
  618.         END ;
  619.         Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  620.         mV := MenuViewers.New(
  621.             TextFrames.NewMenu(name, "^Edit.Menu.Text"),
  622.             TextFrames.NewText(T, 0),
  623.             TextFrames.menuH, x, y)
  624.     END DisplayW;
  625.     PROCEDURE InitStruct(VAR typ: Struct; f: SHORTINT);    
  626.     BEGIN NEW(typ); typ^.form := f; typ^.ref := f; typ^.size := 1
  627.     END InitStruct;
  628.     PROCEDURE Init;
  629.         PROCEDURE EnterTyp(name: ARRAY OF CHAR; form: SHORTINT; size: INTEGER; VAR res: Struct);    
  630.             VAR obj: Object; typ: Struct;
  631.         BEGIN Insert(Index(name), obj);
  632.             NEW(typ); obj^.mode := Typ; obj^.typ := typ;
  633.             typ^.form := form; typ^.strobj := obj; typ^.size := size;
  634.             typ^.mno := 0; typ^.ref := form; res := typ
  635.         END EnterTyp;
  636.         PROCEDURE OpenScope(level: INTEGER; owner: Object);    
  637.             VAR head: Object;
  638.         BEGIN NEW(head);
  639.             head^.mode := Head; head^.a0 := level; head^.link := owner;
  640.             head^.left := topScope; head^.right := NIL; topScope := head
  641.         END OpenScope;
  642.     BEGIN
  643.         IdBuf[0] := 0X; id := 1; topScope := NIL; OpenScope(0, NIL);
  644.         EnterTyp("CHAR", Char, 1, chartyp);
  645.         EnterTyp("SET", Set, 4, settyp);
  646.         EnterTyp("REAL", Real, 4, realtyp);
  647.         EnterTyp("INTEGER", Int, 2, inttyp);
  648.         EnterTyp("LONGINT",  LInt, 4, linttyp);
  649.         EnterTyp("LONGREAL", LReal, 8, lrltyp);
  650.         EnterTyp("SHORTINT", SInt, 1, sinttyp);
  651.         EnterTyp("BOOLEAN", Bool, 1, booltyp);
  652.         EnterTyp("SYSTEM.BYTE", Byte, 1, bytetyp);
  653.         EnterTyp("SYSTEM.PTR", Pointer, 4, sysptrtyp);                                                                                    (*:*)
  654.         universe := topScope; topScope^.right := NIL;
  655.         nofGmod := 1; topScope^.name := 0; GlbMod[0] := topScope; OpenScope(0, NIL);
  656.         NEW(types);
  657.     END Init;
  658.     PROCEDURE GetArgs(VAR S: Texts.Scanner);
  659.         VAR text: Texts.Text; beg, end, time: LONGINT;
  660.     BEGIN
  661.         Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
  662.         IF (S.line#0) OR ((S.class#Texts.Name) & (S.class#Texts.String)) THEN
  663.             Oberon.GetSelection(text, beg, end, time);
  664.             IF time>=0 THEN Texts.OpenScanner(S, text, beg); Texts.Scan(S) END
  665.         END
  666.     END GetArgs;
  667.     PROCEDURE Option(VAR S: Texts.Scanner);
  668.     BEGIN option := 0X;
  669.         Texts.Scan(S);
  670.         IF (S.class=Texts.Char) & (S.c=OptionChar) THEN Texts.Scan(S);
  671.             IF S.class=Texts.Name THEN option := S.s[0]; Texts.Scan(S) END
  672.         END
  673.     END Option;
  674. (*    PROCEDURE QualIdent(VAR name, first, second: ARRAY OF CHAR);
  675.         VAR i, j: INTEGER; ch: CHAR;
  676.     BEGIN
  677.         i:=0; ch:=name[0];
  678.         WHILE (ch#".") & (ch#0X) DO first[i]:=ch; INC(i); ch:=name[i] END;
  679.         first[i]:=0X; INC(i); j:=0; ch:=name[i];
  680.         WHILE ch#0X DO second[j]:=ch; INC(i); INC(j); ch:=name[i] END;
  681.         second[j]:=0X
  682.     END QualIdent;  *)
  683.     PROCEDURE QualIdent(VAR name, first, second: ARRAY OF CHAR);
  684.         VAR i, j: INTEGER; ch: CHAR;
  685.     BEGIN
  686.         i:=0; ch:=name[0];
  687.         WHILE (ch#".") & (ch#0X) DO first[i]:=ch; INC(i); ch:=name[i] END;
  688.         first[i]:=0X; 
  689.         IF ch#0X THEN
  690.             j:=0; INC(i); ch:=name[i];
  691.             WHILE ch#0X DO second[j]:=ch; INC(i); INC(j); ch:=name[i] END;
  692.             second[j]:=0X
  693.         ELSE second[0]:=0X END
  694.     END QualIdent;
  695.     PROCEDURE ShowDef*;
  696.         VAR
  697.             S: Texts.Scanner;
  698.             mod, dummy: ARRAY 32 OF CHAR;
  699.             obj: Object;
  700.     BEGIN
  701.         GetArgs(S);
  702.         IF (S.class=Texts.Name) OR (S.class=Texts.String) THEN
  703.             QualIdent(S.s, mod, dummy); Option(S);
  704.             Init;
  705.             ReadSym(mod, obj);
  706.             IF ~err THEN
  707.                 showObj := FALSE; WriteModule(obj);
  708.                 Append(mod, ".Def"); DisplayW(mod)
  709.             END
  710.         END
  711.     END ShowDef;
  712.     PROCEDURE ShowObj*;
  713.         VAR
  714.             S: Texts.Scanner;
  715.             mod, objName, qualid: ARRAY 32 OF CHAR;
  716.             obj: Object;
  717.     BEGIN
  718.         GetArgs(S);
  719.         IF (S.class=Texts.Name) OR (S.class=Texts.String) THEN
  720.             COPY(S.s, qualid); QualIdent(S.s, mod, objName); Option(S);
  721.             Init;
  722.             ReadSym(mod, obj);
  723.             IF ~err THEN
  724.                 obj := obj^.link; id := Index(objName);
  725.                 WHILE (obj # NIL) & (Diff(id, obj^.name) # 0) DO obj := obj^.right END ;
  726.                 IF obj # NIL THEN
  727.                     showObj := TRUE; first := TRUE;
  728.                     WriteObject(obj, obj^.mode);
  729.                     DisplayW(qualid)
  730.                 END
  731.             END
  732.         END
  733.     END ShowObj;
  734.     PROCEDURE ShowTree*;
  735.         VAR
  736.             S: Texts.Scanner;
  737.             modName, dummy: ARRAY 32 OF CHAR;
  738.             obj: Object;
  739.     BEGIN
  740.         GetArgs(S); Init;
  741.         WHILE (S.class = Texts.Name) OR (S.class=Texts.String) DO
  742.             QualIdent(S.s, modName, dummy); Option(S);
  743.             ReadSym(modName, obj); IF err THEN RETURN END
  744.         END ;
  745.         WriteRecords(types^.sub, 1);
  746.         DisplayW("Browser.ShowTree")
  747.     END ShowTree;
  748.     PROCEDURE SetExtension*;    (* "sym file extension"*)
  749.         VAR S: Texts.Scanner;
  750.     BEGIN GetArgs(S);
  751.         IF S.class = Texts.String THEN COPY(S.s, symFileExt) END
  752.     END SetExtension;
  753. BEGIN
  754.     Texts.OpenWriter(W);
  755.     InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
  756.     InitStruct(stringtyp, String); InitStruct(niltyp, NilTyp);
  757.     symFileExt := ".Sym"
  758. END Browser.
  759.